home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / lib / tcl / dist / tclVar.c < prev   
Encoding:
C/C++ Source or Header  |  1992-05-07  |  62.4 KB  |  2,263 lines
  1. /* 
  2.  * tclVar.c --
  3.  *
  4.  *    This file contains routines that implement Tcl variables
  5.  *    (both scalars and arrays).
  6.  *
  7.  *    The implementation of arrays is modelled after an initial
  8.  *    implementation by Karl Lehenbauer, Mark Diekhans and
  9.  *    Peter da Silva.
  10.  *
  11.  * Copyright 1987-1991 Regents of the University of California
  12.  * Permission to use, copy, modify, and distribute this
  13.  * software and its documentation for any purpose and without
  14.  * fee is hereby granted, provided that the above copyright
  15.  * notice appear in all copies.  The University of California
  16.  * makes no representations about the suitability of this
  17.  * software for any purpose.  It is provided "as is" without
  18.  * express or implied warranty.
  19.  */
  20.  
  21. #ifndef lint
  22. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclVar.c,v 1.27 92/05/07 09:24:59 ouster Exp $ SPRITE (Berkeley)";
  23. #endif
  24.  
  25. #include "tclInt.h"
  26.  
  27. /*
  28.  * The strings below are used to indicate what went wrong when a
  29.  * variable access is denied.
  30.  */
  31.  
  32. static char *noSuchVar =    "no such variable";
  33. static char *isArray =        "variable is array";
  34. static char *needArray =    "variable isn't array";
  35. static char *noSuchElement =    "no such element in array";
  36. static char *traceActive =    "trace is active on variable";
  37.  
  38. /*
  39.  * Forward references to procedures defined later in this file:
  40.  */
  41.  
  42. static  char *        CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
  43.                 Tcl_HashEntry *hPtr, char *name1, char *name2,
  44.                 int flags));
  45. static void        DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
  46. static void        DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
  47.                 Var *varPtr, int flags));
  48. static Var *        NewVar _ANSI_ARGS_((int space));
  49. static ArraySearch *    ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
  50.                 Var *varPtr, char *varName, char *string));
  51. static void        VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
  52.                 char *name1, char *name2, char *operation,
  53.                 char *reason));
  54.  
  55. /*
  56.  *----------------------------------------------------------------------
  57.  *
  58.  * Tcl_GetVar --
  59.  *
  60.  *    Return the value of a Tcl variable.
  61.  *
  62.  * Results:
  63.  *    The return value points to the current value of varName.  If
  64.  *    the variable is not defined or can't be read because of a clash
  65.  *    in array usage then a NULL pointer is returned and an error
  66.  *    message is left in interp->result if the TCL_LEAVE_ERR_MSG
  67.  *    flag is set.  Note:  the return value is only valid up until
  68.  *    the next call to Tcl_SetVar or Tcl_SetVar2;  if you depend on
  69.  *    the value lasting longer than that, then make yourself a private
  70.  *    copy.
  71.  *
  72.  * Side effects:
  73.  *    None.
  74.  *
  75.  *----------------------------------------------------------------------
  76.  */
  77.  
  78. char *
  79. Tcl_GetVar(interp, varName, flags)
  80.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  81.                  * to be looked up. */
  82.     char *varName;        /* Name of a variable in interp. */
  83.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  84.                  * or TCL_LEAVE_ERR_MSG bits. */
  85. {
  86.     register char *p;
  87.  
  88.     /*
  89.      * If varName refers to an array (it ends with a parenthesized
  90.      * element name), then handle it specially.
  91.      */
  92.  
  93.     for (p = varName; *p != '\0'; p++) {
  94.     if (*p == '(') {
  95.         char *result;
  96.         char *open = p;
  97.  
  98.         do {
  99.         p++;
  100.         } while (*p != '\0');
  101.         p--;
  102.         if (*p != ')') {
  103.         goto scalar;
  104.         }
  105.         *open = '\0';
  106.         *p = '\0';
  107.         result = Tcl_GetVar2(interp, varName, open+1, flags);
  108.         *open = '(';
  109.         *p = ')';
  110.         return result;
  111.     }
  112.     }
  113.  
  114.     scalar:
  115.     return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
  116. }
  117.  
  118. /*
  119.  *----------------------------------------------------------------------
  120.  *
  121.  * Tcl_GetVar2 --
  122.  *
  123.  *    Return the value of a Tcl variable, given a two-part name
  124.  *    consisting of array name and element within array.
  125.  *
  126.  * Results:
  127.  *    The return value points to the current value of the variable
  128.  *    given by name1 and name2.  If the specified variable doesn't
  129.  *    exist, or if there is a clash in array usage, then NULL is
  130.  *    returned and a message will be left in interp->result if the
  131.  *    TCL_LEAVE_ERR_MSG flag is set.  Note:  the return value is
  132.  *    only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
  133.  *    if you depend on the value lasting longer than that, then make
  134.  *    yourself a private copy.
  135.  *
  136.  * Side effects:
  137.  *    None.
  138.  *
  139.  *----------------------------------------------------------------------
  140.  */
  141.  
  142. char *
  143. Tcl_GetVar2(interp, name1, name2, flags)
  144.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  145.                  * to be looked up. */
  146.     char *name1;        /* Name of array (if name2 is NULL) or
  147.                  * name of variable. */
  148.     char *name2;        /* If non-null, gives name of element in
  149.                  * array. */
  150.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  151.                  * or TCL_LEAVE_ERR_MSG bits. */
  152. {
  153.     Tcl_HashEntry *hPtr;
  154.     Var *varPtr;
  155.     Interp *iPtr = (Interp *) interp;
  156.     Var *arrayPtr = NULL;
  157.  
  158.     /*
  159.      * Lookup the first name.
  160.      */
  161.  
  162.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  163.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
  164.     } else {
  165.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
  166.     }
  167.     if (hPtr == NULL) {
  168.     if (flags & TCL_LEAVE_ERR_MSG) {
  169.         VarErrMsg(interp, name1, name2, "read", noSuchVar);
  170.     }
  171.     return NULL;
  172.     }
  173.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  174.     if (varPtr->flags & VAR_UPVAR) {
  175.     hPtr = varPtr->value.upvarPtr;
  176.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  177.     }
  178.  
  179.     /*
  180.      * If this is an array reference, then remember the traces on the array
  181.      * and lookup the element within the array.
  182.      */
  183.  
  184.     if (name2 != NULL) {
  185.     if (varPtr->flags & VAR_UNDEFINED) {
  186.         if (flags & TCL_LEAVE_ERR_MSG) {
  187.         VarErrMsg(interp, name1, name2, "read", noSuchVar);
  188.         }
  189.         return NULL;
  190.     } else if (!(varPtr->flags & VAR_ARRAY)) {
  191.         if (flags & TCL_LEAVE_ERR_MSG) {
  192.         VarErrMsg(interp, name1, name2, "read", needArray);
  193.         }
  194.         return NULL;
  195.     }
  196.     arrayPtr = varPtr;
  197.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
  198.     if (hPtr == NULL) {
  199.         if (flags & TCL_LEAVE_ERR_MSG) {
  200.         VarErrMsg(interp, name1, name2, "read", noSuchElement);
  201.         }
  202.         return NULL;
  203.     }
  204.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  205.     }
  206.  
  207.     /*
  208.      * Invoke any traces that have been set for the variable.
  209.      */
  210.  
  211.     if ((varPtr->tracePtr != NULL)
  212.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  213.     char *msg;
  214.  
  215.     msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
  216.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
  217.     if (msg != NULL) {
  218.         VarErrMsg(interp, name1, name2, "read", msg);
  219.         return NULL;
  220.     }
  221.  
  222.     /*
  223.      * Watch out!  The variable could have gotten re-allocated to
  224.      * a larger size.  Fortunately the hash table entry will still
  225.      * be around.
  226.      */
  227.  
  228.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  229.     }
  230.     if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY)) {
  231.     if (flags & TCL_LEAVE_ERR_MSG) {
  232.         VarErrMsg(interp, name1, name2, "read", noSuchVar);
  233.     }
  234.     return NULL;
  235.     }
  236.     return varPtr->value.string;
  237. }
  238.  
  239. /*
  240.  *----------------------------------------------------------------------
  241.  *
  242.  * Tcl_SetVar --
  243.  *
  244.  *    Change the value of a variable.
  245.  *
  246.  * Results:
  247.  *    Returns a pointer to the malloc'ed string holding the new
  248.  *    value of the variable.  The caller should not modify this
  249.  *    string.  If the write operation was disallowed then NULL
  250.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  251.  *    an explanatory message will be left in interp->result.
  252.  *
  253.  * Side effects:
  254.  *    If varName is defined as a local or global variable in interp,
  255.  *    its value is changed to newValue.  If varName isn't currently
  256.  *    defined, then a new global variable by that name is created.
  257.  *
  258.  *----------------------------------------------------------------------
  259.  */
  260.  
  261. char *
  262. Tcl_SetVar(interp, varName, newValue, flags)
  263.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  264.                  * to be looked up. */
  265.     char *varName;        /* Name of a variable in interp. */
  266.     char *newValue;        /* New value for varName. */
  267.     int flags;            /* Various flags that tell how to set value:
  268.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  269.                  * TCL_LIST_ELEMENT, TCL_NO_SPACE, or
  270.                  * TCL_LEAVE_ERR_MSG. */
  271. {
  272.     register char *p;
  273.  
  274.     /*
  275.      * If varName refers to an array (it ends with a parenthesized
  276.      * element name), then handle it specially.
  277.      */
  278.  
  279.     for (p = varName; *p != '\0'; p++) {
  280.     if (*p == '(') {
  281.         char *result;
  282.         char *open = p;
  283.  
  284.         do {
  285.         p++;
  286.         } while (*p != '\0');
  287.         p--;
  288.         if (*p != ')') {
  289.         goto scalar;
  290.         }
  291.         *open = '\0';
  292.         *p = '\0';
  293.         result = Tcl_SetVar2(interp, varName, open+1, newValue, flags);
  294.         *open = '(';
  295.         *p = ')';
  296.         return result;
  297.     }
  298.     }
  299.  
  300.     scalar:
  301.     return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
  302. }
  303.  
  304. /*
  305.  *----------------------------------------------------------------------
  306.  *
  307.  * Tcl_SetVar2 --
  308.  *
  309.  *    Given a two-part variable name, which may refer either to a
  310.  *    scalar variable or an element of an array, change the value
  311.  *    of the variable.  If the named scalar or array or element
  312.  *    doesn't exist then create one.
  313.  *
  314.  * Results:
  315.  *    Returns a pointer to the malloc'ed string holding the new
  316.  *    value of the variable.  The caller should not modify this
  317.  *    string.  If the write operation was disallowed because an
  318.  *    array was expected but not found (or vice versa), then NULL
  319.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  320.  *    an explanatory message will be left in interp->result.
  321.  *
  322.  * Side effects:
  323.  *    The value of the given variable is set.  If either the array
  324.  *    or the entry didn't exist then a new one is created.
  325.  *
  326.  *----------------------------------------------------------------------
  327.  */
  328.  
  329. char *
  330. Tcl_SetVar2(interp, name1, name2, newValue, flags)
  331.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  332.                  * to be looked up. */
  333.     char *name1;        /* If name2 is NULL, this is name of scalar
  334.                  * variable.  Otherwise it is name of array. */
  335.     char *name2;        /* Name of an element within array, or NULL. */
  336.     char *newValue;        /* New value for variable. */
  337.     int flags;            /* Various flags that tell how to set value:
  338.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  339.                  * TCL_LIST_ELEMENT, and TCL_NO_SPACE, or
  340.                  * TCL_LEAVE_ERR_MSG . */
  341. {
  342.     Tcl_HashEntry *hPtr;
  343.     register Var *varPtr = NULL;
  344.                 /* Initial value only used to stop compiler
  345.                  * from complaining; not really needed. */
  346.     register Interp *iPtr = (Interp *) interp;
  347.     int length, new, listFlags;
  348.     Var *arrayPtr = NULL;
  349.  
  350.     /*
  351.      * Lookup the first name.
  352.      */
  353.  
  354.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  355.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &new);
  356.     } else {
  357.     hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
  358.         name1, &new);
  359.     }
  360.     if (!new) {
  361.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  362.     if (varPtr->flags & VAR_UPVAR) {
  363.         hPtr = varPtr->value.upvarPtr;
  364.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  365.     }
  366.     }
  367.  
  368.     /*
  369.      * If this is an array reference, then create a new array (if
  370.      * needed), remember any traces on the array, and lookup the
  371.      * element within the array.
  372.      */
  373.  
  374.     if (name2 != NULL) {
  375.     if (new) {
  376.         varPtr = NewVar(0);
  377.         Tcl_SetHashValue(hPtr, varPtr);
  378.         varPtr->flags = VAR_ARRAY;
  379.         varPtr->value.tablePtr = (Tcl_HashTable *)
  380.             ckalloc(sizeof(Tcl_HashTable));
  381.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  382.     } else {
  383.         if (varPtr->flags & VAR_UNDEFINED) {
  384.         varPtr->flags = VAR_ARRAY;
  385.         varPtr->value.tablePtr = (Tcl_HashTable *)
  386.             ckalloc(sizeof(Tcl_HashTable));
  387.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  388.         } else if (!(varPtr->flags & VAR_ARRAY)) {
  389.         if (flags & TCL_LEAVE_ERR_MSG) {
  390.             VarErrMsg(interp, name1, name2, "set", needArray);
  391.         }
  392.         return NULL;
  393.         }
  394.         arrayPtr = varPtr;
  395.     }
  396.     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &new);
  397.     }
  398.  
  399.     /*
  400.      * Compute how many bytes will be needed for newValue (leave space
  401.      * for a separating space between list elements).
  402.      */
  403.  
  404.     if (flags & TCL_LIST_ELEMENT) {
  405.     length = Tcl_ScanElement(newValue, &listFlags) + 1;
  406.     } else {
  407.     length = strlen(newValue);
  408.     }
  409.  
  410.     /*
  411.      * If the variable doesn't exist then create a new one.  If it
  412.      * does exist then clear its current value unless this is an
  413.      * append operation.
  414.      */
  415.  
  416.     if (new) {
  417.     varPtr = NewVar(length);
  418.     Tcl_SetHashValue(hPtr, varPtr);
  419.     if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
  420.         DeleteSearches(arrayPtr);
  421.     }
  422.     } else {
  423.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  424.     if (varPtr->flags & VAR_ARRAY) {
  425.         if (flags & TCL_LEAVE_ERR_MSG) {
  426.         VarErrMsg(interp, name1, name2, "set", isArray);
  427.         }
  428.         return NULL;
  429.     }
  430.     if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) {
  431.         varPtr->valueLength = 0;
  432.     }
  433.     }
  434.  
  435.     /*
  436.      * Make sure there's enough space to hold the variable's
  437.      * new value.  If not, enlarge the variable's space.
  438.      */
  439.  
  440.     if ((length + varPtr->valueLength) >= varPtr->valueSpace) {
  441.     Var *newVarPtr;
  442.     int newSize;
  443.  
  444.     newSize = 2*varPtr->valueSpace;
  445.     if (newSize <= (length + varPtr->valueLength)) {
  446.         newSize += length;
  447.     }
  448.     newVarPtr = NewVar(newSize);
  449.     newVarPtr->valueLength = varPtr->valueLength;
  450.     newVarPtr->upvarUses = varPtr->upvarUses;
  451.     newVarPtr->tracePtr = varPtr->tracePtr;
  452.     strcpy(newVarPtr->value.string, varPtr->value.string);
  453.     Tcl_SetHashValue(hPtr, newVarPtr);
  454.     ckfree((char *) varPtr);
  455.     varPtr = newVarPtr;
  456.     }
  457.  
  458.     /*
  459.      * Append the new value to the variable, either as a list
  460.      * element or as a string.
  461.      */
  462.  
  463.     if (flags & TCL_LIST_ELEMENT) {
  464.     if ((varPtr->valueLength > 0) && !(flags & TCL_NO_SPACE)) {
  465.         varPtr->value.string[varPtr->valueLength] = ' ';
  466.         varPtr->valueLength++;
  467.     }
  468.     varPtr->valueLength += Tcl_ConvertElement(newValue,
  469.         varPtr->value.string + varPtr->valueLength, listFlags);
  470.     varPtr->value.string[varPtr->valueLength] = 0;
  471.     } else {
  472.     strcpy(varPtr->value.string + varPtr->valueLength, newValue);
  473.     varPtr->valueLength += length;
  474.     }
  475.     varPtr->flags &= ~VAR_UNDEFINED;
  476.  
  477.     /*
  478.      * Invoke any write traces for the variable.
  479.      */
  480.  
  481.     if ((varPtr->tracePtr != NULL)
  482.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  483.     char *msg;
  484.  
  485.     msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
  486.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES);
  487.     if (msg != NULL) {
  488.         VarErrMsg(interp, name1, name2, "set", msg);
  489.         return NULL;
  490.     }
  491.  
  492.     /*
  493.      * Watch out!  The variable could have gotten re-allocated to
  494.      * a larger size.  Fortunately the hash table entry will still
  495.      * be around.
  496.      */
  497.  
  498.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  499.     }
  500.     return varPtr->value.string;
  501. }
  502.  
  503. /*
  504.  *----------------------------------------------------------------------
  505.  *
  506.  * Tcl_UnsetVar --
  507.  *
  508.  *    Delete a variable, so that it may not be accessed anymore.
  509.  *
  510.  * Results:
  511.  *    Returns 0 if the variable was successfully deleted, -1
  512.  *    if the variable can't be unset.  In the event of an error,
  513.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  514.  *    is left in interp->result.
  515.  *
  516.  * Side effects:
  517.  *    If varName is defined as a local or global variable in interp,
  518.  *    it is deleted.
  519.  *
  520.  *----------------------------------------------------------------------
  521.  */
  522.  
  523. int
  524. Tcl_UnsetVar(interp, varName, flags)
  525.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  526.                  * to be looked up. */
  527.     char *varName;        /* Name of a variable in interp.  May be
  528.                  * either a scalar name or an array name
  529.                  * or an element in an array. */
  530.     int flags;            /* OR-ed combination of any of
  531.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  532. {
  533.     register char *p;
  534.     int result;
  535.  
  536.     /*
  537.      * Figure out whether this is an array reference, then call
  538.      * Tcl_UnsetVar2 to do all the real work.
  539.      */
  540.  
  541.     for (p = varName; *p != '\0'; p++) {
  542.     if (*p == '(') {
  543.         char *open = p;
  544.  
  545.         do {
  546.         p++;
  547.         } while (*p != '\0');
  548.         p--;
  549.         if (*p != ')') {
  550.         goto scalar;
  551.         }
  552.         *open = '\0';
  553.         *p = '\0';
  554.         result = Tcl_UnsetVar2(interp, varName, open+1, flags);
  555.         *open = '(';
  556.         *p = ')';
  557.         return result;
  558.     }
  559.     }
  560.  
  561.     scalar:
  562.     return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
  563. }
  564.  
  565. /*
  566.  *----------------------------------------------------------------------
  567.  *
  568.  * Tcl_UnsetVar2 --
  569.  *
  570.  *    Delete a variable, given a 2-part name.
  571.  *
  572.  * Results:
  573.  *    Returns 0 if the variable was successfully deleted, -1
  574.  *    if the variable can't be unset.  In the event of an error,
  575.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  576.  *    is left in interp->result.
  577.  *
  578.  * Side effects:
  579.  *    If name1 and name2 indicate a local or global variable in interp,
  580.  *    it is deleted.  If name1 is an array name and name2 is NULL, then
  581.  *    the whole array is deleted.
  582.  *
  583.  *----------------------------------------------------------------------
  584.  */
  585.  
  586. int
  587. Tcl_UnsetVar2(interp, name1, name2, flags)
  588.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  589.                  * to be looked up. */
  590.     char *name1;        /* Name of variable or array. */
  591.     char *name2;        /* Name of element within array or NULL. */
  592.     int flags;            /* OR-ed combination of any of
  593.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  594. {
  595.     Tcl_HashEntry *hPtr, dummyEntry;
  596.     Var *varPtr, dummyVar;
  597.     Interp *iPtr = (Interp *) interp;
  598.     Var *arrayPtr = NULL;
  599.  
  600.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  601.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
  602.     } else {
  603.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
  604.     }
  605.     if (hPtr == NULL) {
  606.     if (flags & TCL_LEAVE_ERR_MSG) {
  607.         VarErrMsg(interp, name1, name2, "unset", noSuchVar);
  608.     }
  609.     return -1;
  610.     }
  611.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  612.  
  613.     /*
  614.      * For global variables referenced in procedures, leave the procedure's
  615.      * reference variable in place, but unset the global variable.  Can't
  616.      * decrement the actual variable's use count, since we didn't delete
  617.      * the reference variable.
  618.      */
  619.  
  620.     if (varPtr->flags & VAR_UPVAR) {
  621.     hPtr = varPtr->value.upvarPtr;
  622.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  623.     }
  624.  
  625.     /*
  626.      * If the variable being deleted is an element of an array, then
  627.      * remember trace procedures on the overall array and find the
  628.      * element to delete.
  629.      */
  630.  
  631.     if (name2 != NULL) {
  632.     if (!(varPtr->flags & VAR_ARRAY)) {
  633.         if (flags & TCL_LEAVE_ERR_MSG) {
  634.         VarErrMsg(interp, name1, name2, "unset", needArray);
  635.         }
  636.         return -1;
  637.     }
  638.     if (varPtr->searchPtr != NULL) {
  639.         DeleteSearches(varPtr);
  640.     }
  641.     arrayPtr = varPtr;
  642.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
  643.     if (hPtr == NULL) {
  644.         if (flags & TCL_LEAVE_ERR_MSG) {
  645.         VarErrMsg(interp, name1, name2, "unset", noSuchElement);
  646.         }
  647.         return -1;
  648.     }
  649.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  650.     }
  651.  
  652.     /*
  653.      * If there is a trace active on this variable or if the variable
  654.      * is already being deleted then don't delete the variable:  it
  655.      * isn't safe, since there are procedures higher up on the stack
  656.      * that will use pointers to the variable.  Also don't delete an
  657.      * array if there are traces active on any of its elements.
  658.      */
  659.  
  660.     if (varPtr->flags &
  661.         (VAR_TRACE_ACTIVE|VAR_ELEMENT_ACTIVE)) {
  662.     if (flags & TCL_LEAVE_ERR_MSG) {
  663.         VarErrMsg(interp, name1, name2, "unset", traceActive);
  664.     }
  665.     return -1;
  666.     }
  667.  
  668.     /*
  669.      * The code below is tricky, because of the possibility that
  670.      * a trace procedure might try to access a variable being
  671.      * deleted.  To handle this situation gracefully, copy the
  672.      * contents of the variable and its hash table entry to
  673.      * dummy variables, then clean up the actual variable so that
  674.      * it's been completely deleted before the traces are called.
  675.      * Then call the traces, and finally clean up the variable's
  676.      * storage using the dummy copies.
  677.      */
  678.  
  679.     dummyVar = *varPtr;
  680.     Tcl_SetHashValue(&dummyEntry, &dummyVar);
  681.     if (varPtr->upvarUses == 0) {
  682.     Tcl_DeleteHashEntry(hPtr);
  683.     ckfree((char *) varPtr);
  684.     } else {
  685.     varPtr->flags = VAR_UNDEFINED;
  686.     varPtr->tracePtr = NULL;
  687.     }
  688.  
  689.     /*
  690.      * Call trace procedures for the variable being deleted and delete
  691.      * its traces.
  692.      */
  693.  
  694.     if ((dummyVar.tracePtr != NULL)
  695.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  696.     (void) CallTraces(iPtr, arrayPtr, &dummyEntry, name1, name2,
  697.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  698.     while (dummyVar.tracePtr != NULL) {
  699.         VarTrace *tracePtr = dummyVar.tracePtr;
  700.         dummyVar.tracePtr = tracePtr->nextPtr;
  701.         ckfree((char *) tracePtr);
  702.     }
  703.     }
  704.  
  705.     /*
  706.      * If the variable is an array, delete all of its elements.  This
  707.      * must be done after calling the traces on the array, above (that's
  708.      * the way traces are defined).
  709.      */
  710.  
  711.     if (dummyVar.flags & VAR_ARRAY) {
  712.     DeleteArray(iPtr, name1, &dummyVar,
  713.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  714.     }
  715.     if (dummyVar.flags & VAR_UNDEFINED) {
  716.     if (flags & TCL_LEAVE_ERR_MSG) {
  717.         VarErrMsg(interp, name1, name2, "unset", 
  718.             (name2 == NULL) ? noSuchVar : noSuchElement);
  719.     }
  720.     return -1;
  721.     }
  722.     return 0;
  723. }
  724.  
  725. /*
  726.  *----------------------------------------------------------------------
  727.  *
  728.  * Tcl_TraceVar --
  729.  *
  730.  *    Arrange for reads and/or writes to a variable to cause a
  731.  *    procedure to be invoked, which can monitor the operations
  732.  *    and/or change their actions.
  733.  *
  734.  * Results:
  735.  *    A standard Tcl return value.
  736.  *
  737.  * Side effects:
  738.  *    A trace is set up on the variable given by varName, such that
  739.  *    future references to the variable will be intermediated by
  740.  *    proc.  See the manual entry for complete details on the calling
  741.  *    sequence for proc.
  742.  *
  743.  *----------------------------------------------------------------------
  744.  */
  745.  
  746. int
  747. Tcl_TraceVar(interp, varName, flags, proc, clientData)
  748.     Tcl_Interp *interp;        /* Interpreter in which variable is
  749.                  * to be traced. */
  750.     char *varName;        /* Name of variable;  may end with "(index)"
  751.                  * to signify an array reference. */
  752.     int flags;            /* OR-ed collection of bits, including any
  753.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  754.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  755.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  756.                  * invoked upon varName. */
  757.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  758. {
  759.     register char *p;
  760.  
  761.     /*
  762.      * If varName refers to an array (it ends with a parenthesized
  763.      * element name), then handle it specially.
  764.      */
  765.  
  766.     for (p = varName; *p != '\0'; p++) {
  767.     if (*p == '(') {
  768.         int result;
  769.         char *open = p;
  770.  
  771.         do {
  772.         p++;
  773.         } while (*p != '\0');
  774.         p--;
  775.         if (*p != ')') {
  776.         goto scalar;
  777.         }
  778.         *open = '\0';
  779.         *p = '\0';
  780.         result = Tcl_TraceVar2(interp, varName, open+1, flags,
  781.             proc, clientData);
  782.         *open = '(';
  783.         *p = ')';
  784.         return result;
  785.     }
  786.     }
  787.  
  788.     scalar:
  789.     return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
  790.         proc, clientData);
  791. }
  792.  
  793. /*
  794.  *----------------------------------------------------------------------
  795.  *
  796.  * Tcl_TraceVar2 --
  797.  *
  798.  *    Arrange for reads and/or writes to a variable to cause a
  799.  *    procedure to be invoked, which can monitor the operations
  800.  *    and/or change their actions.
  801.  *
  802.  * Results:
  803.  *    A standard Tcl return value.
  804.  *
  805.  * Side effects:
  806.  *    A trace is set up on the variable given by name1 and name2, such
  807.  *    that future references to the variable will be intermediated by
  808.  *    proc.  See the manual entry for complete details on the calling
  809.  *    sequence for proc.
  810.  *
  811.  *----------------------------------------------------------------------
  812.  */
  813.  
  814. int
  815. Tcl_TraceVar2(interp, name1, name2, flags, proc, clientData)
  816.     Tcl_Interp *interp;        /* Interpreter in which variable is
  817.                  * to be traced. */
  818.     char *name1;        /* Name of scalar variable or array. */
  819.     char *name2;        /* Name of element within array;  NULL means
  820.                  * trace applies to scalar variable or array
  821.                  * as-a-whole. */
  822.     int flags;            /* OR-ed collection of bits, including any
  823.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  824.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  825.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  826.                  * invoked upon varName. */
  827.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  828. {
  829.     Tcl_HashEntry *hPtr;
  830.     Var *varPtr = NULL;        /* Initial value only used to stop compiler
  831.                  * from complaining; not really needed. */
  832.     Interp *iPtr = (Interp *) interp;
  833.     register VarTrace *tracePtr;
  834.     int new;
  835.  
  836.     /*
  837.      * Locate the variable, making a new (undefined) one if necessary.
  838.      */
  839.  
  840.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  841.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &new);
  842.     } else {
  843.     hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, name1, &new);
  844.     }
  845.     if (!new) {
  846.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  847.     if (varPtr->flags & VAR_UPVAR) {
  848.         hPtr = varPtr->value.upvarPtr;
  849.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  850.     }
  851.     }
  852.  
  853.     /*
  854.      * If the trace is to be on an array element, make sure that the
  855.      * variable is an array variable.  If the variable doesn't exist
  856.      * then define it as an empty array.  Then find the specific
  857.      * array element.
  858.      */
  859.  
  860.     if (name2 != NULL) {
  861.     if (new) {
  862.         varPtr = NewVar(0);
  863.         Tcl_SetHashValue(hPtr, varPtr);
  864.         varPtr->flags = VAR_ARRAY;
  865.         varPtr->value.tablePtr = (Tcl_HashTable *)
  866.             ckalloc(sizeof(Tcl_HashTable));
  867.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  868.     } else {
  869.         if (varPtr->flags & VAR_UNDEFINED) {
  870.         varPtr->flags = VAR_ARRAY;
  871.         varPtr->value.tablePtr = (Tcl_HashTable *)
  872.             ckalloc(sizeof(Tcl_HashTable));
  873.         Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  874.         } else if (!(varPtr->flags & VAR_ARRAY)) {
  875.         iPtr->result = needArray;
  876.         return TCL_ERROR;
  877.         }
  878.     }
  879.     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &new);
  880.     }
  881.  
  882.     if (new) {
  883.     if ((name2 != NULL) && (varPtr->searchPtr != NULL)) {
  884.         DeleteSearches(varPtr);
  885.     }
  886.     varPtr = NewVar(0);
  887.     varPtr->flags = VAR_UNDEFINED;
  888.     Tcl_SetHashValue(hPtr, varPtr);
  889.     } else {
  890.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  891.     }
  892.  
  893.     /*
  894.      * Set up trace information.
  895.      */
  896.  
  897.     tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
  898.     tracePtr->traceProc = proc;
  899.     tracePtr->clientData = clientData;
  900.     tracePtr->flags = flags &
  901.         (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
  902.     tracePtr->nextPtr = varPtr->tracePtr;
  903.     varPtr->tracePtr = tracePtr;
  904.     return TCL_OK;
  905. }
  906.  
  907. /*
  908.  *----------------------------------------------------------------------
  909.  *
  910.  * Tcl_UntraceVar --
  911.  *
  912.  *    Remove a previously-created trace for a variable.
  913.  *
  914.  * Results:
  915.  *    None.
  916.  *
  917.  * Side effects:
  918.  *    If there exists a trace for the variable given by varName
  919.  *    with the given flags, proc, and clientData, then that trace
  920.  *    is removed.
  921.  *
  922.  *----------------------------------------------------------------------
  923.  */
  924.  
  925. void
  926. Tcl_UntraceVar(interp, varName, flags, proc, clientData)
  927.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  928.     char *varName;        /* Name of variable;  may end with "(index)"
  929.                  * to signify an array reference. */
  930.     int flags;            /* OR-ed collection of bits describing
  931.                  * current trace, including any of
  932.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  933.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  934.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  935.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  936. {
  937.     register char *p;
  938.  
  939.     /*
  940.      * If varName refers to an array (it ends with a parenthesized
  941.      * element name), then handle it specially.
  942.      */
  943.  
  944.     for (p = varName; *p != '\0'; p++) {
  945.     if (*p == '(') {
  946.         char *open = p;
  947.  
  948.         do {
  949.         p++;
  950.         } while (*p != '\0');
  951.         p--;
  952.         if (*p != ')') {
  953.         goto scalar;
  954.         }
  955.         *open = '\0';
  956.         *p = '\0';
  957.         Tcl_UntraceVar2(interp, varName, open+1, flags, proc, clientData);
  958.         *open = '(';
  959.         *p = ')';
  960.         return;
  961.     }
  962.     }
  963.  
  964.     scalar:
  965.     Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
  966. }
  967.  
  968. /*
  969.  *----------------------------------------------------------------------
  970.  *
  971.  * Tcl_UntraceVar2 --
  972.  *
  973.  *    Remove a previously-created trace for a variable.
  974.  *
  975.  * Results:
  976.  *    None.
  977.  *
  978.  * Side effects:
  979.  *    If there exists a trace for the variable given by name1
  980.  *    and name2 with the given flags, proc, and clientData, then
  981.  *    that trace is removed.
  982.  *
  983.  *----------------------------------------------------------------------
  984.  */
  985.  
  986. void
  987. Tcl_UntraceVar2(interp, name1, name2, flags, proc, clientData)
  988.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  989.     char *name1;        /* Name of variable or array. */
  990.     char *name2;        /* Name of element within array;  NULL means
  991.                  * trace applies to scalar variable or array
  992.                  * as-a-whole. */
  993.     int flags;            /* OR-ed collection of bits describing
  994.                  * current trace, including any of
  995.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  996.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  997.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  998.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  999. {
  1000.     register VarTrace *tracePtr;
  1001.     VarTrace *prevPtr;
  1002.     Var *varPtr;
  1003.     Interp *iPtr = (Interp *) interp;
  1004.     Tcl_HashEntry *hPtr;
  1005.     ActiveVarTrace *activePtr;
  1006.  
  1007.     /*
  1008.      * First, lookup the variable.
  1009.      */
  1010.  
  1011.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  1012.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
  1013.     } else {
  1014.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
  1015.     }
  1016.     if (hPtr == NULL) {
  1017.     return;
  1018.     }
  1019.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1020.     if (varPtr->flags & VAR_UPVAR) {
  1021.     hPtr = varPtr->value.upvarPtr;
  1022.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1023.     }
  1024.     if (name2 != NULL) {
  1025.     if (!(varPtr->flags & VAR_ARRAY)) {
  1026.         return;
  1027.     }
  1028.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
  1029.     if (hPtr == NULL) {
  1030.         return;
  1031.     }
  1032.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1033.     }
  1034.  
  1035.     flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
  1036.     for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
  1037.         prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
  1038.     if (tracePtr == NULL) {
  1039.         return;
  1040.     }
  1041.     if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
  1042.         && (tracePtr->clientData == clientData)) {
  1043.         break;
  1044.     }
  1045.     }
  1046.  
  1047.     /*
  1048.      * The code below makes it possible to delete traces while traces
  1049.      * are active:  it makes sure that the deleted trace won't be
  1050.      * processed by CallTraces.
  1051.      */
  1052.  
  1053.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  1054.         activePtr = activePtr->nextPtr) {
  1055.     if (activePtr->nextTracePtr == tracePtr) {
  1056.         activePtr->nextTracePtr = tracePtr->nextPtr;
  1057.     }
  1058.     }
  1059.     if (prevPtr == NULL) {
  1060.     varPtr->tracePtr = tracePtr->nextPtr;
  1061.     } else {
  1062.     prevPtr->nextPtr = tracePtr->nextPtr;
  1063.     }
  1064.     ckfree((char *) tracePtr);
  1065. }
  1066.  
  1067. /*
  1068.  *----------------------------------------------------------------------
  1069.  *
  1070.  * Tcl_VarTraceInfo --
  1071.  *
  1072.  *    Return the clientData value associated with a trace on a
  1073.  *    variable.  This procedure can also be used to step through
  1074.  *    all of the traces on a particular variable that have the
  1075.  *    same trace procedure.
  1076.  *
  1077.  * Results:
  1078.  *    The return value is the clientData value associated with
  1079.  *    a trace on the given variable.  Information will only be
  1080.  *    returned for a trace with proc as trace procedure.  If
  1081.  *    the clientData argument is NULL then the first such trace is
  1082.  *    returned;  otherwise, the next relevant one after the one
  1083.  *    given by clientData will be returned.  If the variable
  1084.  *    doesn't exist, or if there are no (more) traces for it,
  1085.  *    then NULL is returned.
  1086.  *
  1087.  * Side effects:
  1088.  *    None.
  1089.  *
  1090.  *----------------------------------------------------------------------
  1091.  */
  1092.  
  1093. ClientData
  1094. Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
  1095.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1096.     char *varName;        /* Name of variable;  may end with "(index)"
  1097.                  * to signify an array reference. */
  1098.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1099.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1100.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1101.                  * by this procedure, so this call will
  1102.                  * return the next trace after that one.
  1103.                  * If NULL, this call will return the
  1104.                  * first trace. */
  1105. {
  1106.     register char *p;
  1107.  
  1108.     /*
  1109.      * If varName refers to an array (it ends with a parenthesized
  1110.      * element name), then handle it specially.
  1111.      */
  1112.  
  1113.     for (p = varName; *p != '\0'; p++) {
  1114.     if (*p == '(') {
  1115.         ClientData result;
  1116.         char *open = p;
  1117.  
  1118.         do {
  1119.         p++;
  1120.         } while (*p != '\0');
  1121.         p--;
  1122.         if (*p != ')') {
  1123.         goto scalar;
  1124.         }
  1125.         *open = '\0';
  1126.         *p = '\0';
  1127.         result = Tcl_VarTraceInfo2(interp, varName, open+1, flags, proc,
  1128.         prevClientData);
  1129.         *open = '(';
  1130.         *p = ')';
  1131.         return result;
  1132.     }
  1133.     }
  1134.  
  1135.     scalar:
  1136.     return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc,
  1137.         prevClientData);
  1138. }
  1139.  
  1140. /*
  1141.  *----------------------------------------------------------------------
  1142.  *
  1143.  * Tcl_VarTraceInfo2 --
  1144.  *
  1145.  *    Same as Tcl_VarTraceInfo, except takes name in two pieces
  1146.  *    instead of one.
  1147.  *
  1148.  * Results:
  1149.  *    Same as Tcl_VarTraceInfo.
  1150.  *
  1151.  * Side effects:
  1152.  *    None.
  1153.  *
  1154.  *----------------------------------------------------------------------
  1155.  */
  1156.  
  1157. ClientData
  1158. Tcl_VarTraceInfo2(interp, name1, name2, flags, proc, prevClientData)
  1159.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1160.     char *name1;        /* Name of variable or array. */
  1161.     char *name2;        /* Name of element within array;  NULL means
  1162.                  * trace applies to scalar variable or array
  1163.                  * as-a-whole. */
  1164.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1165.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1166.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1167.                  * by this procedure, so this call will
  1168.                  * return the next trace after that one.
  1169.                  * If NULL, this call will return the
  1170.                  * first trace. */
  1171. {
  1172.     register VarTrace *tracePtr;
  1173.     Var *varPtr;
  1174.     Interp *iPtr = (Interp *) interp;
  1175.     Tcl_HashEntry *hPtr;
  1176.  
  1177.     /*
  1178.      * First, lookup the variable.
  1179.      */
  1180.  
  1181.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  1182.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
  1183.     } else {
  1184.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
  1185.     }
  1186.     if (hPtr == NULL) {
  1187.     return NULL;
  1188.     }
  1189.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1190.     if (varPtr->flags & VAR_UPVAR) {
  1191.     hPtr = varPtr->value.upvarPtr;
  1192.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1193.     }
  1194.     if (name2 != NULL) {
  1195.     if (!(varPtr->flags & VAR_ARRAY)) {
  1196.         return NULL;
  1197.     }
  1198.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
  1199.     if (hPtr == NULL) {
  1200.         return NULL;
  1201.     }
  1202.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1203.     }
  1204.  
  1205.     /*
  1206.      * Find the relevant trace, if any, and return its clientData.
  1207.      */
  1208.  
  1209.     tracePtr = varPtr->tracePtr;
  1210.     if (prevClientData != NULL) {
  1211.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1212.         if ((tracePtr->clientData == prevClientData)
  1213.             && (tracePtr->traceProc == proc)) {
  1214.         tracePtr = tracePtr->nextPtr;
  1215.         break;
  1216.         }
  1217.     }
  1218.     }
  1219.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1220.     if (tracePtr->traceProc == proc) {
  1221.         return tracePtr->clientData;
  1222.     }
  1223.     }
  1224.     return NULL;
  1225. }
  1226.  
  1227. /*
  1228.  *----------------------------------------------------------------------
  1229.  *
  1230.  * Tcl_SetCmd --
  1231.  *
  1232.  *    This procedure is invoked to process the "set" Tcl command.
  1233.  *    See the user documentation for details on what it does.
  1234.  *
  1235.  * Results:
  1236.  *    A standard Tcl result value.
  1237.  *
  1238.  * Side effects:
  1239.  *    A variable's value may be changed.
  1240.  *
  1241.  *----------------------------------------------------------------------
  1242.  */
  1243.  
  1244.     /* ARGSUSED */
  1245. int
  1246. Tcl_SetCmd(dummy, interp, argc, argv)
  1247.     ClientData dummy;            /* Not used. */
  1248.     register Tcl_Interp *interp;    /* Current interpreter. */
  1249.     int argc;                /* Number of arguments. */
  1250.     char **argv;            /* Argument strings. */
  1251. {
  1252.     if (argc == 2) {
  1253.     char *value;
  1254.  
  1255.     value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  1256.     if (value == NULL) {
  1257.         return TCL_ERROR;
  1258.     }
  1259.     interp->result = value;
  1260.     return TCL_OK;
  1261.     } else if (argc == 3) {
  1262.     char *result;
  1263.  
  1264.     result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG);
  1265.     if (result == NULL) {
  1266.         return TCL_ERROR;
  1267.     }
  1268.     interp->result = result;
  1269.     return TCL_OK;
  1270.     } else {
  1271.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1272.         argv[0], " varName ?newValue?\"", (char *) NULL);
  1273.     return TCL_ERROR;
  1274.     }
  1275. }
  1276.  
  1277. /*
  1278.  *----------------------------------------------------------------------
  1279.  *
  1280.  * Tcl_UnsetCmd --
  1281.  *
  1282.  *    This procedure is invoked to process the "unset" Tcl command.
  1283.  *    See the user documentation for details on what it does.
  1284.  *
  1285.  * Results:
  1286.  *    A standard Tcl result value.
  1287.  *
  1288.  * Side effects:
  1289.  *    See the user documentation.
  1290.  *
  1291.  *----------------------------------------------------------------------
  1292.  */
  1293.  
  1294.     /* ARGSUSED */
  1295. int
  1296. Tcl_UnsetCmd(dummy, interp, argc, argv)
  1297.     ClientData dummy;            /* Not used. */
  1298.     register Tcl_Interp *interp;    /* Current interpreter. */
  1299.     int argc;                /* Number of arguments. */
  1300.     char **argv;            /* Argument strings. */
  1301. {
  1302.     int i;
  1303.  
  1304.     if (argc < 2) {
  1305.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1306.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1307.     return TCL_ERROR;
  1308.     }
  1309.     for (i = 1; i < argc; i++) {
  1310.     if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != 0) {
  1311.         return TCL_ERROR;
  1312.     }
  1313.     }
  1314.     return TCL_OK;
  1315. }
  1316.  
  1317. /*
  1318.  *----------------------------------------------------------------------
  1319.  *
  1320.  * Tcl_AppendCmd --
  1321.  *
  1322.  *    This procedure is invoked to process the "append" Tcl command.
  1323.  *    See the user documentation for details on what it does.
  1324.  *
  1325.  * Results:
  1326.  *    A standard Tcl result value.
  1327.  *
  1328.  * Side effects:
  1329.  *    A variable's value may be changed.
  1330.  *
  1331.  *----------------------------------------------------------------------
  1332.  */
  1333.  
  1334.     /* ARGSUSED */
  1335. int
  1336. Tcl_AppendCmd(dummy, interp, argc, argv)
  1337.     ClientData dummy;            /* Not used. */
  1338.     register Tcl_Interp *interp;    /* Current interpreter. */
  1339.     int argc;                /* Number of arguments. */
  1340.     char **argv;            /* Argument strings. */
  1341. {
  1342.     int i;
  1343.     char *result = NULL;        /* (Initialization only needed to keep
  1344.                      * the compiler from complaining) */
  1345.  
  1346.     if (argc < 3) {
  1347.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1348.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1349.     return TCL_ERROR;
  1350.     }
  1351.  
  1352.     for (i = 2; i < argc; i++) {
  1353.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1354.         TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
  1355.     if (result == NULL) {
  1356.         return TCL_ERROR;
  1357.     }
  1358.     }
  1359.     interp->result = result;
  1360.     return TCL_OK;
  1361. }
  1362.  
  1363. /*
  1364.  *----------------------------------------------------------------------
  1365.  *
  1366.  * Tcl_LappendCmd --
  1367.  *
  1368.  *    This procedure is invoked to process the "lappend" Tcl command.
  1369.  *    See the user documentation for details on what it does.
  1370.  *
  1371.  * Results:
  1372.  *    A standard Tcl result value.
  1373.  *
  1374.  * Side effects:
  1375.  *    A variable's value may be changed.
  1376.  *
  1377.  *----------------------------------------------------------------------
  1378.  */
  1379.  
  1380.     /* ARGSUSED */
  1381. int
  1382. Tcl_LappendCmd(dummy, interp, argc, argv)
  1383.     ClientData dummy;            /* Not used. */
  1384.     register Tcl_Interp *interp;    /* Current interpreter. */
  1385.     int argc;                /* Number of arguments. */
  1386.     char **argv;            /* Argument strings. */
  1387. {
  1388.     int i;
  1389.     char *result = NULL;        /* (Initialization only needed to keep
  1390.                      * the compiler from complaining) */
  1391.  
  1392.     if (argc < 3) {
  1393.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1394.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1395.     return TCL_ERROR;
  1396.     }
  1397.  
  1398.     for (i = 2; i < argc; i++) {
  1399.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1400.         TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
  1401.     if (result == NULL) {
  1402.         return TCL_ERROR;
  1403.     }
  1404.     }
  1405.     interp->result = result;
  1406.     return TCL_OK;
  1407. }
  1408.  
  1409. /*
  1410.  *----------------------------------------------------------------------
  1411.  *
  1412.  * Tcl_ArrayCmd --
  1413.  *
  1414.  *    This procedure is invoked to process the "array" Tcl command.
  1415.  *    See the user documentation for details on what it does.
  1416.  *
  1417.  * Results:
  1418.  *    A standard Tcl result value.
  1419.  *
  1420.  * Side effects:
  1421.  *    See the user documentation.
  1422.  *
  1423.  *----------------------------------------------------------------------
  1424.  */
  1425.  
  1426.     /* ARGSUSED */
  1427. int
  1428. Tcl_ArrayCmd(dummy, interp, argc, argv)
  1429.     ClientData dummy;            /* Not used. */
  1430.     register Tcl_Interp *interp;    /* Current interpreter. */
  1431.     int argc;                /* Number of arguments. */
  1432.     char **argv;            /* Argument strings. */
  1433. {
  1434.     int length;
  1435.     char c;
  1436.     Var *varPtr;
  1437.     Tcl_HashEntry *hPtr;
  1438.     Interp *iPtr = (Interp *) interp;
  1439.  
  1440.     if (argc < 3) {
  1441.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1442.         argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
  1443.     return TCL_ERROR;
  1444.     }
  1445.  
  1446.     /*
  1447.      * Locate the array variable (and it better be an array).
  1448.      */
  1449.  
  1450.     if (iPtr->varFramePtr == NULL) {
  1451.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  1452.     } else {
  1453.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  1454.     }
  1455.     if (hPtr == NULL) {
  1456.     notArray:
  1457.     Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
  1458.         (char *) NULL);
  1459.     return TCL_ERROR;
  1460.     }
  1461.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1462.     if (varPtr->flags & VAR_UPVAR) {
  1463.     varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
  1464.     }
  1465.     if (!(varPtr->flags & VAR_ARRAY)) {
  1466.     goto notArray;
  1467.     }
  1468.  
  1469.     /*
  1470.      * Dispatch based on the option.
  1471.      */
  1472.  
  1473.     c = argv[1][0];
  1474.     length = strlen(argv[1]);
  1475.     if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
  1476.     ArraySearch *searchPtr;
  1477.  
  1478.     if (argc != 4) {
  1479.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1480.             argv[0], " anymore arrayName searchId\"", (char *) NULL);
  1481.         return TCL_ERROR;
  1482.     }
  1483.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1484.     if (searchPtr == NULL) {
  1485.         return TCL_ERROR;
  1486.     }
  1487.     while (1) {
  1488.         Var *varPtr2;
  1489.  
  1490.         if (searchPtr->nextEntry != NULL) {
  1491.         varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
  1492.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1493.             break;
  1494.         }
  1495.         }
  1496.         searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
  1497.         if (searchPtr->nextEntry == NULL) {
  1498.         interp->result = "0";
  1499.         return TCL_OK;
  1500.         }
  1501.     }
  1502.     interp->result = "1";
  1503.     return TCL_OK;
  1504.     } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
  1505.     ArraySearch *searchPtr, *prevPtr;
  1506.  
  1507.     if (argc != 4) {
  1508.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1509.             argv[0], " donesearch arrayName searchId\"", (char *) NULL);
  1510.         return TCL_ERROR;
  1511.     }
  1512.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1513.     if (searchPtr == NULL) {
  1514.         return TCL_ERROR;
  1515.     }
  1516.     if (varPtr->searchPtr == searchPtr) {
  1517.         varPtr->searchPtr = searchPtr->nextPtr;
  1518.     } else {
  1519.         for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
  1520.         if (prevPtr->nextPtr == searchPtr) {
  1521.             prevPtr->nextPtr = searchPtr->nextPtr;
  1522.             break;
  1523.         }
  1524.         }
  1525.     }
  1526.     ckfree((char *) searchPtr);
  1527.     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
  1528.         && (length >= 2)) {
  1529.     Tcl_HashSearch search;
  1530.     Var *varPtr2;
  1531.  
  1532.     if (argc != 3) {
  1533.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1534.             argv[0], " names arrayName\"", (char *) NULL);
  1535.         return TCL_ERROR;
  1536.     }
  1537.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1538.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1539.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1540.         if (varPtr2->flags & VAR_UNDEFINED) {
  1541.         continue;
  1542.         }
  1543.         Tcl_AppendElement(interp,
  1544.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), 0);
  1545.     }
  1546.     } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
  1547.         && (length >= 2)) {
  1548.     ArraySearch *searchPtr;
  1549.     Tcl_HashEntry *hPtr;
  1550.  
  1551.     if (argc != 4) {
  1552.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1553.             argv[0], " nextelement arrayName searchId\"",
  1554.             (char *) NULL);
  1555.         return TCL_ERROR;
  1556.     }
  1557.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1558.     if (searchPtr == NULL) {
  1559.         return TCL_ERROR;
  1560.     }
  1561.     while (1) {
  1562.         Var *varPtr2;
  1563.  
  1564.         hPtr = searchPtr->nextEntry;
  1565.         if (hPtr == NULL) {
  1566.         hPtr = Tcl_NextHashEntry(&searchPtr->search);
  1567.         if (hPtr == NULL) {
  1568.             return TCL_OK;
  1569.         }
  1570.         } else {
  1571.         searchPtr->nextEntry = NULL;
  1572.         }
  1573.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1574.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1575.         break;
  1576.         }
  1577.     }
  1578.     interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1579.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  1580.         && (length >= 2)) {
  1581.     Tcl_HashSearch search;
  1582.     Var *varPtr2;
  1583.     int size;
  1584.  
  1585.     if (argc != 3) {
  1586.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1587.             argv[0], " size arrayName\"", (char *) NULL);
  1588.         return TCL_ERROR;
  1589.     }
  1590.     size = 0;
  1591.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1592.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1593.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1594.         if (varPtr2->flags & VAR_UNDEFINED) {
  1595.         continue;
  1596.         }
  1597.         size++;
  1598.     }
  1599.     sprintf(interp->result, "%d", size);
  1600.     } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
  1601.         && (length >= 2)) {
  1602.     ArraySearch *searchPtr;
  1603.  
  1604.     if (argc != 3) {
  1605.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1606.             argv[0], " startsearch arrayName\"", (char *) NULL);
  1607.         return TCL_ERROR;
  1608.     }
  1609.     searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
  1610.     if (varPtr->searchPtr == NULL) {
  1611.         searchPtr->id = 1;
  1612.         Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
  1613.     } else {
  1614.         char string[20];
  1615.  
  1616.         searchPtr->id = varPtr->searchPtr->id + 1;
  1617.         sprintf(string, "%d", searchPtr->id);
  1618.         Tcl_AppendResult(interp, "s-", string, "-", argv[2],
  1619.             (char *) NULL);
  1620.     }
  1621.     searchPtr->varPtr = varPtr;
  1622.     searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
  1623.         &searchPtr->search);
  1624.     searchPtr->nextPtr = varPtr->searchPtr;
  1625.     varPtr->searchPtr = searchPtr;
  1626.     } else {
  1627.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1628.         "\": should be anymore, donesearch, names, nextelement, ",
  1629.         "size, or startsearch", (char *) NULL);
  1630.     return TCL_ERROR;
  1631.     }
  1632.     return TCL_OK;
  1633. }
  1634.  
  1635. /*
  1636.  *----------------------------------------------------------------------
  1637.  *
  1638.  * Tcl_GlobalCmd --
  1639.  *
  1640.  *    This procedure is invoked to process the "global" Tcl command.
  1641.  *    See the user documentation for details on what it does.
  1642.  *
  1643.  * Results:
  1644.  *    A standard Tcl result value.
  1645.  *
  1646.  * Side effects:
  1647.  *    See the user documentation.
  1648.  *
  1649.  *----------------------------------------------------------------------
  1650.  */
  1651.  
  1652.     /* ARGSUSED */
  1653. int
  1654. Tcl_GlobalCmd(dummy, interp, argc, argv)
  1655.     ClientData dummy;            /* Not used. */
  1656.     Tcl_Interp *interp;            /* Current interpreter. */
  1657.     int argc;                /* Number of arguments. */
  1658.     char **argv;            /* Argument strings. */
  1659. {
  1660.     Var *varPtr, *gVarPtr;
  1661.     register Interp *iPtr = (Interp *) interp;
  1662.     Tcl_HashEntry *hPtr, *hPtr2;
  1663.     int new;
  1664.  
  1665.     if (argc < 2) {
  1666.     Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
  1667.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1668.     return TCL_ERROR;
  1669.     }
  1670.     if (iPtr->varFramePtr == NULL) {
  1671.     return TCL_OK;
  1672.     }
  1673.  
  1674.     for (argc--, argv++; argc > 0; argc--, argv++) {
  1675.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, *argv, &new);
  1676.     if (new) {
  1677.         gVarPtr = NewVar(0);
  1678.         gVarPtr->flags |= VAR_UNDEFINED;
  1679.         Tcl_SetHashValue(hPtr, gVarPtr);
  1680.     } else {
  1681.         gVarPtr = (Var *) Tcl_GetHashValue(hPtr);
  1682.     }
  1683.     hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, *argv, &new);
  1684.     if (!new) {
  1685.         Var *varPtr;
  1686.         varPtr = (Var *) Tcl_GetHashValue(hPtr2);
  1687.         if (varPtr->flags & VAR_UPVAR) {
  1688.         continue;
  1689.         } else {
  1690.         Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", *argv,
  1691.             "\" already exists", (char *) NULL);
  1692.         return TCL_ERROR;
  1693.         }
  1694.     }
  1695.     varPtr = NewVar(0);
  1696.     varPtr->flags |= VAR_UPVAR;
  1697.     varPtr->value.upvarPtr = hPtr;
  1698.     gVarPtr->upvarUses++;
  1699.     Tcl_SetHashValue(hPtr2, varPtr);
  1700.     }
  1701.     return TCL_OK;
  1702. }
  1703.  
  1704. /*
  1705.  *----------------------------------------------------------------------
  1706.  *
  1707.  * Tcl_UpvarCmd --
  1708.  *
  1709.  *    This procedure is invoked to process the "upvar" Tcl command.
  1710.  *    See the user documentation for details on what it does.
  1711.  *
  1712.  * Results:
  1713.  *    A standard Tcl result value.
  1714.  *
  1715.  * Side effects:
  1716.  *    See the user documentation.
  1717.  *
  1718.  *----------------------------------------------------------------------
  1719.  */
  1720.  
  1721.     /* ARGSUSED */
  1722. int
  1723. Tcl_UpvarCmd(dummy, interp, argc, argv)
  1724.     ClientData dummy;            /* Not used. */
  1725.     Tcl_Interp *interp;            /* Current interpreter. */
  1726.     int argc;                /* Number of arguments. */
  1727.     char **argv;            /* Argument strings. */
  1728. {
  1729.     register Interp *iPtr = (Interp *) interp;
  1730.     int result;
  1731.     CallFrame *framePtr;
  1732.     Var *varPtr = NULL;
  1733.     Tcl_HashTable *upVarTablePtr;
  1734.     Tcl_HashEntry *hPtr, *hPtr2;
  1735.     int new;
  1736.     Var *upVarPtr;
  1737.  
  1738.     if (argc < 3) {
  1739.     upvarSyntax:
  1740.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1741.         " ?level? otherVar localVar ?otherVar localVar ...?\"",
  1742.         (char *) NULL);
  1743.     return TCL_ERROR;
  1744.     }
  1745.  
  1746.     /*
  1747.      * Find the hash table containing the variable being referenced.
  1748.      */
  1749.  
  1750.     result = TclGetFrame(interp, argv[1], &framePtr);
  1751.     if (result == -1) {
  1752.     return TCL_ERROR;
  1753.     }
  1754.     argc -= result+1;
  1755.     argv += result+1;
  1756.     if (framePtr == NULL) {
  1757.     upVarTablePtr = &iPtr->globalTable;
  1758.     } else {
  1759.     upVarTablePtr = &framePtr->varTable;
  1760.     }
  1761.  
  1762.     if ((argc & 1) != 0) {
  1763.     goto upvarSyntax;
  1764.     }
  1765.  
  1766.     /*
  1767.      * Iterate over all the pairs of (local variable, other variable)
  1768.      * names.  For each pair, create a hash table entry in the upper
  1769.      * context (if the name wasn't there already), then associate it
  1770.      * with a new local variable.
  1771.      */
  1772.  
  1773.     while (argc > 0) {
  1774.         hPtr = Tcl_CreateHashEntry(upVarTablePtr, argv[0], &new);
  1775.         if (new) {
  1776.             upVarPtr = NewVar(0);
  1777.             upVarPtr->flags |= VAR_UNDEFINED;
  1778.             Tcl_SetHashValue(hPtr, upVarPtr);
  1779.         } else {
  1780.             upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
  1781.         if (upVarPtr->flags & VAR_UPVAR) {
  1782.         hPtr = upVarPtr->value.upvarPtr;
  1783.         upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
  1784.         }
  1785.         }
  1786.  
  1787.         hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
  1788.                     argv[1], &new);
  1789.         if (!new) {
  1790.             Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", argv[1],
  1791.                 "\" already exists", (char *) NULL);
  1792.             return TCL_ERROR;
  1793.         }
  1794.         varPtr = NewVar(0);
  1795.         varPtr->flags |= VAR_UPVAR;
  1796.         varPtr->value.upvarPtr = hPtr;
  1797.         upVarPtr->upvarUses++;
  1798.         Tcl_SetHashValue(hPtr2, varPtr);
  1799.  
  1800.         argc -= 2;
  1801.         argv += 2;
  1802.     }
  1803.     return TCL_OK;
  1804. }
  1805.  
  1806. /*
  1807.  *----------------------------------------------------------------------
  1808.  *
  1809.  * TclDeleteVars --
  1810.  *
  1811.  *    This procedure is called to recycle all the storage space
  1812.  *    associated with a table of variables.  For this procedure
  1813.  *    to work correctly, it must not be possible for any of the
  1814.  *    variable in the table to be accessed from Tcl commands
  1815.  *    (e.g. from trace procedures).
  1816.  *
  1817.  * Results:
  1818.  *    None.
  1819.  *
  1820.  * Side effects:
  1821.  *    Variables are deleted and trace procedures are invoked, if
  1822.  *    any are declared.
  1823.  *
  1824.  *----------------------------------------------------------------------
  1825.  */
  1826.  
  1827. void
  1828. TclDeleteVars(iPtr, tablePtr)
  1829.     Interp *iPtr;        /* Interpreter to which variables belong. */
  1830.     Tcl_HashTable *tablePtr;    /* Hash table containing variables to
  1831.                  * delete. */
  1832. {
  1833.     Tcl_HashSearch search;
  1834.     Tcl_HashEntry *hPtr;
  1835.     register Var *varPtr;
  1836.     int flags, globalFlag;
  1837.  
  1838.     flags = TCL_TRACE_UNSETS;
  1839.     if (tablePtr == &iPtr->globalTable) {
  1840.     flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
  1841.     }
  1842.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
  1843.         hPtr = Tcl_NextHashEntry(&search)) {
  1844.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1845.  
  1846.     /*
  1847.      * For global/upvar variables referenced in procedures, free up the
  1848.      * local space and then decrement the reference count on the
  1849.      * variable referred to.  If there are no more references to the
  1850.      * global/upvar and it is undefined and has no traces set, then
  1851.      * follow on and delete the referenced variable too.
  1852.      */
  1853.  
  1854.     globalFlag = 0;
  1855.     if (varPtr->flags & VAR_UPVAR) {
  1856.         hPtr = varPtr->value.upvarPtr;
  1857.         ckfree((char *) varPtr);
  1858.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1859.         varPtr->upvarUses--;
  1860.         if ((varPtr->upvarUses != 0) || !(varPtr->flags & VAR_UNDEFINED)
  1861.             || (varPtr->tracePtr != NULL)) {
  1862.         continue;
  1863.         }
  1864.         globalFlag = TCL_GLOBAL_ONLY;
  1865.     }
  1866.  
  1867.     /*
  1868.      * Invoke traces on the variable that is being deleted, then
  1869.      * free up the variable's space (no need to free the hash entry
  1870.      * here, unless we're dealing with a global variable:  the
  1871.      * hash entries will be deleted automatically when the whole
  1872.      * table is deleted).
  1873.      */
  1874.  
  1875.     if (varPtr->tracePtr != NULL) {
  1876.         (void) CallTraces(iPtr, (Var *) NULL, hPtr,
  1877.             Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL,
  1878.             flags | globalFlag);
  1879.         while (varPtr->tracePtr != NULL) {
  1880.         VarTrace *tracePtr = varPtr->tracePtr;
  1881.         varPtr->tracePtr = tracePtr->nextPtr;
  1882.         ckfree((char *) tracePtr);
  1883.         }
  1884.     }
  1885.     if (varPtr->flags & VAR_ARRAY) {
  1886.         DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
  1887.             flags | globalFlag);
  1888.     }
  1889.     if (globalFlag) {
  1890.         Tcl_DeleteHashEntry(hPtr);
  1891.     }
  1892.     ckfree((char *) varPtr);
  1893.     }
  1894.     Tcl_DeleteHashTable(tablePtr);
  1895. }
  1896.  
  1897. /*
  1898.  *----------------------------------------------------------------------
  1899.  *
  1900.  * CallTraces --
  1901.  *
  1902.  *    This procedure is invoked to find and invoke relevant
  1903.  *    trace procedures associated with a particular operation on
  1904.  *    a variable.  This procedure invokes traces both on the
  1905.  *    variable and on its containing array (where relevant).
  1906.  *
  1907.  * Results:
  1908.  *    The return value is NULL if no trace procedures were invoked, or
  1909.  *    if all the invoked trace procedures returned successfully.
  1910.  *    The return value is non-zero if a trace procedure returned an
  1911.  *    error (in this case no more trace procedures were invoked after
  1912.  *    the error was returned).  In this case the return value is a
  1913.  *    pointer to a static string describing the error.
  1914.  *
  1915.  * Side effects:
  1916.  *    Almost anything can happen, depending on trace;  this procedure
  1917.  *    itself doesn't have any side effects.
  1918.  *
  1919.  *----------------------------------------------------------------------
  1920.  */
  1921.  
  1922. static char *
  1923. CallTraces(iPtr, arrayPtr, hPtr, name1, name2, flags)
  1924.     Interp *iPtr;            /* Interpreter containing variable. */
  1925.     register Var *arrayPtr;        /* Pointer to array variable that
  1926.                      * contains the variable, or NULL if
  1927.                      * the variable isn't an element of an
  1928.                      * array. */
  1929.     Tcl_HashEntry *hPtr;        /* Hash table entry corresponding to
  1930.                      * variable whose traces are to be
  1931.                      * invoked. */
  1932.     char *name1, *name2;        /* Variable's two-part name. */
  1933.     int flags;                /* Flags to pass to trace procedures:
  1934.                      * indicates what's happening to
  1935.                      * variable, plus other stuff like
  1936.                      * TCL_GLOBAL_ONLY and
  1937.                      * TCL_INTERP_DESTROYED. */
  1938. {
  1939.     Var *varPtr;
  1940.     register VarTrace *tracePtr;
  1941.     ActiveVarTrace active;
  1942.     char *result;
  1943.     int savedArrayFlags = 0;        /* (Initialization not needed except
  1944.                      * to prevent compiler warning) */
  1945.  
  1946.     /*
  1947.      * If there are already similar trace procedures active for the
  1948.      * variable, don't call them again.
  1949.      */
  1950.  
  1951.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1952.     if (varPtr->flags & VAR_TRACE_ACTIVE) {
  1953.     return NULL;
  1954.     }
  1955.     varPtr->flags |= VAR_TRACE_ACTIVE;
  1956.  
  1957.     /*
  1958.      * Invoke traces on the array containing the variable, if relevant.
  1959.      */
  1960.  
  1961.     result = NULL;
  1962.     active.nextPtr = iPtr->activeTracePtr;
  1963.     iPtr->activeTracePtr = &active;
  1964.     if (arrayPtr != NULL) {
  1965.     savedArrayFlags = arrayPtr->flags;
  1966.     arrayPtr->flags |= VAR_ELEMENT_ACTIVE;
  1967.     for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
  1968.         tracePtr = active.nextTracePtr) {
  1969.         active.nextTracePtr = tracePtr->nextPtr;
  1970.         if (!(tracePtr->flags & flags)) {
  1971.         continue;
  1972.         }
  1973.         result = (*tracePtr->traceProc)(tracePtr->clientData,
  1974.             (Tcl_Interp *) iPtr, name1, name2, flags);
  1975.         if (result != NULL) {
  1976.         if (flags & TCL_TRACE_UNSETS) {
  1977.             result = NULL;
  1978.         } else {
  1979.             goto done;
  1980.         }
  1981.         }
  1982.     }
  1983.     }
  1984.  
  1985.     /*
  1986.      * Invoke traces on the variable itself.
  1987.      */
  1988.  
  1989.     if (flags & TCL_TRACE_UNSETS) {
  1990.     flags |= TCL_TRACE_DESTROYED;
  1991.     }
  1992.     for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
  1993.         tracePtr = active.nextTracePtr) {
  1994.     active.nextTracePtr = tracePtr->nextPtr;
  1995.     if (!(tracePtr->flags & flags)) {
  1996.         continue;
  1997.     }
  1998.     result = (*tracePtr->traceProc)(tracePtr->clientData,
  1999.         (Tcl_Interp *) iPtr, name1, name2, flags);
  2000.     if (result != NULL) {
  2001.         if (flags & TCL_TRACE_UNSETS) {
  2002.         result = NULL;
  2003.         } else {
  2004.         goto done;
  2005.         }
  2006.     }
  2007.     }
  2008.  
  2009.     /*
  2010.      * Restore the variable's flags, remove the record of our active
  2011.      * traces, and then return.  Remember that the variable could have
  2012.      * been re-allocated during the traces, but its hash entry won't
  2013.      * change.
  2014.      */
  2015.  
  2016.     done:
  2017.     if (arrayPtr != NULL) {
  2018.     arrayPtr->flags = savedArrayFlags;
  2019.     }
  2020.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  2021.     varPtr->flags &= ~VAR_TRACE_ACTIVE;
  2022.     iPtr->activeTracePtr = active.nextPtr;
  2023.     return result;
  2024. }
  2025.  
  2026. /*
  2027.  *----------------------------------------------------------------------
  2028.  *
  2029.  * NewVar --
  2030.  *
  2031.  *    Create a new variable with a given initial value.
  2032.  *
  2033.  * Results:
  2034.  *    The return value is a pointer to the new variable structure.
  2035.  *    The variable will not be part of any hash table yet, and its
  2036.  *    upvarUses count is initialized to 0.  Its initial value will
  2037.  *    be empty, but "space" bytes will be available in the value
  2038.  *    area.
  2039.  *
  2040.  * Side effects:
  2041.  *    Storage gets allocated.
  2042.  *
  2043.  *----------------------------------------------------------------------
  2044.  */
  2045.  
  2046. static Var *
  2047. NewVar(space)
  2048.     int space;        /* Minimum amount of space to allocate
  2049.              * for variable's value. */
  2050. {
  2051.     int extra;
  2052.     register Var *varPtr;
  2053.  
  2054.     extra = space - sizeof(varPtr->value);
  2055.     if (extra < 0) {
  2056.     extra = 0;
  2057.     space = sizeof(varPtr->value);
  2058.     }
  2059.     varPtr = (Var *) ckalloc((unsigned) (sizeof(Var) + extra));
  2060.     varPtr->valueLength = 0;
  2061.     varPtr->valueSpace = space;
  2062.     varPtr->upvarUses = 0;
  2063.     varPtr->tracePtr = NULL;
  2064.     varPtr->searchPtr = NULL;
  2065.     varPtr->flags = 0;
  2066.     varPtr->value.string[0] = 0;
  2067.     return varPtr;
  2068. }
  2069.  
  2070. /*
  2071.  *----------------------------------------------------------------------
  2072.  *
  2073.  * ParseSearchId --
  2074.  *
  2075.  *    This procedure translates from a string to a pointer to an
  2076.  *    active array search (if there is one that matches the string).
  2077.  *
  2078.  * Results:
  2079.  *    The return value is a pointer to the array search indicated
  2080.  *    by string, or NULL if there isn't one.  If NULL is returned,
  2081.  *    interp->result contains an error message.
  2082.  *
  2083.  * Side effects:
  2084.  *    None.
  2085.  *
  2086.  *----------------------------------------------------------------------
  2087.  */
  2088.  
  2089. static ArraySearch *
  2090. ParseSearchId(interp, varPtr, varName, string)
  2091.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2092.     Var *varPtr;        /* Array variable search is for. */
  2093.     char *varName;        /* Name of array variable that search is
  2094.                  * supposed to be for. */
  2095.     char *string;        /* String containing id of search.  Must have
  2096.                  * form "search-num-var" where "num" is a
  2097.                  * decimal number and "var" is a variable
  2098.                  * name. */
  2099. {
  2100.     char *end;
  2101.     int id;
  2102.     ArraySearch *searchPtr;
  2103.  
  2104.     /*
  2105.      * Parse the id into the three parts separated by dashes.
  2106.      */
  2107.  
  2108.     if ((string[0] != 's') || (string[1] != '-')) {
  2109.     syntax:
  2110.     Tcl_AppendResult(interp, "illegal search identifier \"", string,
  2111.         "\"", (char *) NULL);
  2112.     return NULL;
  2113.     }
  2114.     id = strtoul(string+2, &end, 10);
  2115.     if ((end == (string+2)) || (*end != '-')) {
  2116.     goto syntax;
  2117.     }
  2118.     if (strcmp(end+1, varName) != 0) {
  2119.     Tcl_AppendResult(interp, "search identifier \"", string,
  2120.         "\" isn't for variable \"", varName, "\"", (char *) NULL);
  2121.     return NULL;
  2122.     }
  2123.  
  2124.     /*
  2125.      * Search through the list of active searches on the interpreter
  2126.      * to see if the desired one exists.
  2127.      */
  2128.  
  2129.     for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
  2130.         searchPtr = searchPtr->nextPtr) {
  2131.     if (searchPtr->id == id) {
  2132.         return searchPtr;
  2133.     }
  2134.     }
  2135.     Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
  2136.         (char *) NULL);
  2137.     return NULL;
  2138. }
  2139.  
  2140. /*
  2141.  *----------------------------------------------------------------------
  2142.  *
  2143.  * DeleteSearches --
  2144.  *
  2145.  *    This procedure is called to free up all of the searches
  2146.  *    associated with an array variable.
  2147.  *
  2148.  * Results:
  2149.  *    None.
  2150.  *
  2151.  * Side effects:
  2152.  *    Memory is released to the storage allocator.
  2153.  *
  2154.  *----------------------------------------------------------------------
  2155.  */
  2156.  
  2157. static void
  2158. DeleteSearches(arrayVarPtr)
  2159.     register Var *arrayVarPtr;        /* Variable whose searches are
  2160.                      * to be deleted. */
  2161. {
  2162.     ArraySearch *searchPtr;
  2163.  
  2164.     while (arrayVarPtr->searchPtr != NULL) {
  2165.     searchPtr = arrayVarPtr->searchPtr;
  2166.     arrayVarPtr->searchPtr = searchPtr->nextPtr;
  2167.     ckfree((char *) searchPtr);
  2168.     }
  2169. }
  2170.  
  2171. /*
  2172.  *----------------------------------------------------------------------
  2173.  *
  2174.  * DeleteArray --
  2175.  *
  2176.  *    This procedure is called to free up everything in an array
  2177.  *    variable.  It's the caller's responsibility to make sure
  2178.  *    that the array is no longer accessible before this procedure
  2179.  *    is called.
  2180.  *
  2181.  * Results:
  2182.  *    None.
  2183.  *
  2184.  * Side effects:
  2185.  *    All storage associated with varPtr's array elements is deleted
  2186.  *    (including the hash table).  Any delete trace procedures for
  2187.  *    array elements are invoked.
  2188.  *
  2189.  *----------------------------------------------------------------------
  2190.  */
  2191.  
  2192. static void
  2193. DeleteArray(iPtr, arrayName, varPtr, flags)
  2194.     Interp *iPtr;            /* Interpreter containing array. */
  2195.     char *arrayName;            /* Name of array (used for trace
  2196.                      * callbacks). */
  2197.     Var *varPtr;            /* Pointer to variable structure. */
  2198.     int flags;                /* Flags to pass to CallTraces:
  2199.                      * TCL_TRACE_UNSETS and sometimes
  2200.                      * TCL_INTERP_DESTROYED and/or
  2201.                      * TCL_GLOBAL_ONLY. */
  2202. {
  2203.     Tcl_HashSearch search;
  2204.     register Tcl_HashEntry *hPtr;
  2205.     register Var *elPtr;
  2206.  
  2207.     DeleteSearches(varPtr);
  2208.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  2209.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  2210.     elPtr = (Var *) Tcl_GetHashValue(hPtr);
  2211.     if (elPtr->tracePtr != NULL) {
  2212.         (void) CallTraces(iPtr, (Var *) NULL, hPtr, arrayName,
  2213.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
  2214.         while (elPtr->tracePtr != NULL) {
  2215.         VarTrace *tracePtr = elPtr->tracePtr;
  2216.         elPtr->tracePtr = tracePtr->nextPtr;
  2217.         ckfree((char *) tracePtr);
  2218.         }
  2219.     }
  2220.     if (elPtr->flags & VAR_SEARCHES_POSSIBLE) {
  2221.         panic("DeleteArray found searches on array alement!");
  2222.     }
  2223.     ckfree((char *) elPtr);
  2224.     }
  2225.     Tcl_DeleteHashTable(varPtr->value.tablePtr);
  2226.     ckfree((char *) varPtr->value.tablePtr);
  2227. }
  2228.  
  2229. /*
  2230.  *----------------------------------------------------------------------
  2231.  *
  2232.  * VarErrMsg --
  2233.  *
  2234.  *    Generate a reasonable error message describing why a variable
  2235.  *    operation failed.
  2236.  *
  2237.  * Results:
  2238.  *    None.
  2239.  *
  2240.  * Side effects:
  2241.  *    Interp->result is reset to hold a message identifying the
  2242.  *    variable given by name1 and name2 and describing why the
  2243.  *    variable operation failed.
  2244.  *
  2245.  *----------------------------------------------------------------------
  2246.  */
  2247.  
  2248. static void
  2249. VarErrMsg(interp, name1, name2, operation, reason)
  2250.     Tcl_Interp *interp;        /* Interpreter in which to record message. */
  2251.     char *name1, *name2;    /* Variable's two-part name. */
  2252.     char *operation;        /* String describing operation that failed,
  2253.                  * e.g. "read", "set", or "unset". */
  2254.     char *reason;        /* String describing why operation failed. */
  2255. {
  2256.     Tcl_ResetResult(interp);
  2257.     Tcl_AppendResult(interp, "can't ", operation, " \"", name1, (char *) NULL);
  2258.     if (name2 != NULL) {
  2259.     Tcl_AppendResult(interp, "(", name2, ")", (char *) NULL);
  2260.     }
  2261.     Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
  2262. }
  2263.